perm filename PLTCMX.OLD[MSS,LCS] blob sn#107249 filedate 1974-06-16 generic text, type T, neo UTF8
00100	C**** PLTCMD, FILLER, NNN, UNPACK, ROFF ********
38800		SUBROUTINE PLTCMD
38900	CC	IMPLICIT INTEGER(A-Q,S-Z)
39000		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100		DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200		COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
39400		COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700		EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800		1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
39950		F78F(1)='(78F)'
39960		FA5(1)='(A5) '
39970		FA1(1)='(A1) '
40000	
40100		IF(I2.NE.'X')GO TO 1
40150	CC	ML=' '
40200		I2=0
40300		RXC=0
40400		RMOV1(1)='Y'
40500		NAME=0
40600	14	KA=0
40700	3	KA=KA+1
40710	CC	IF(ML.EQ.' ')GO TO 15
40715		IF(ML.EQ.0)GO TO 15
40720		K=K-2
40725		ML=ML-1
40730		IF(ML.EQ.0)GO TO 10
40740		GO TO 31
40800	15	TYPE 2,KA
40900		ACCEPT 11,K,ML
40950	C  TYPE LAST NAME, NUMBER  FOR A SERIES
41000	50	IF(K.EQ.' ')GO TO 10
41100		IF(K.EQ.'99')GO TO 140
41200	C  99=BACKUP
41300	31	IF(LOOKD(K))GO TO 56
41400	C JUMP IF FILE FOUND
41500		TYPE 55
41600		GO TO 15
41700	55	FORMAT(' FILE NOT FOUND'/)
41750	11	FORMAT(A5,I)
41800	56	NMS(KA)=K
41810	CC	IF(ML.EQ.' ')GO TO 5
41820		IF(ML.EQ.0)GO TO 5
41855		RJH='Y'
41877		GO TO 21
41900	5	TYPE 8
42000		ACCEPT FA5,RJH
42100		IF(RJH.EQ.'99')GO TO 15
42200		IF(RJH.NE.'Y')RJH=0
42300		IF(RJH.EQ.0)REREAD F78F,RJH
42400	C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500	21	RMOV1(KA+1)=RJH
42600		RMOV2(KA)=RJH
42700		GO TO 3
42800	140	KA=KA-1
42900		GO TO 15
43000	
43100	10	KB=KA-1
43110		IF(I3.NE.'G')GO TO 22
43120		RSIZ=1
43130		GO TO 222
43200	22	TYPE 9
43300		ACCEPT F78F,RSIZ
43400		IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500	222	KA=0
43600	
43700	1	IF(NAME.NE.0)GO TO 12
43800		IF(KA.EQ.KB)CALL PLOT(0,0,99)
43900		NAME=NMS(KA+1)
44000		TYPE 111,NAME
44100		RETURN
44200	12	KA=KA+1
44300		NAME=0
44400		RJD=1
44500		IF(INP(3).EQ.'C')RJD=0
44600	C  'PXC' = CALCOMP OUTPUT
44700		RJH=0
44800		RJB=RSIZ
44900		RJC=RSIZ
45000		RJG=0
45100		RJE=1
45200		RJF=1
45300		IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400		IF(RMOV1(KA).NE.0)RJE=0
45500		IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600	2	FORMAT(' TYPE FILE NAME',I2,1X$)
45700	8	FORMAT(' MOVE UP AT END? ',$)
45800	9	FORMAT(' SIZE FACTOR? ',$)
45900	111	FORMAT(1XA5/)
46000		END
47000		SUBROUTINE FILLER(IFILL,QJB,QCENT,BX,BY)
47100		DIMENSION IFILL(1)
47200		COMMON /DL/IXRX,SAVER,NAME
47300		COMMON /SIZ/RSZ,JCEN,KCEN
47400		COMMON /FL/IC,N,NQ,RZ,XGP
47500		COMMON /STF/RSTFAC(8),RSTJC
47600		COMMON /PLTR/IPLT,RHT,DIS
47700		COMMON/DPY/IGO,RXGP,ITOP,IBOT
48000		PX=1
48100		IF(BX.EQ.0)BX=1
48200		IF(BY.EQ.0)BY=1
48300		IF(BX)PX=-1
48400		IXGP=XGP
48500		RSI=RSTJC*BY
48600	C  RI IS INVERSION FACTOR
48700		BZ=BY/BX
48800		RT=RSTJC*BX
48900	C  RS=HORIZ.    RT=VERT.
49000		JXGP=RXGP
49100		NX=2
49200	C  NX IS POINTER IN X ARRAY
49300		ID=IFILL(NX)
49400		IF(IPLT)GO TO 101
49500		RBZ=QJB*RSZ
49600		RXX=RSZ*RT
49700	C  WHAT ABOUT RXX???????? 
49800		RYX=QCENT*RSZ
49900		RXY=RSI*RSZ
50000		GO TO 100
50100	101	RXX=RT*DIS
50200		RXY=RSI*RHT
50300		RBZ=QJB*DIS
50400		RYX=QCENT*RHT
50500	100	RM=-1000
50600		IF(PX)RM=-RM
50700		I=NX+1
50800	103	CALL UNPACK(IA,IB,IFILL(I))
50900		IF(IA.NE.IFILL(I+1)/10000)GO TO 102
51000		I=I+1
51100		GO TO 103
51200	102	G=IA*RT+QJB
51300		H=IB*RSI+QCENT
51400		IF(IPLT)GO TO 200
51500		CALL LINES(G,H,3)
51600		GO TO 300
51700	200	IF(IXRX.EQ.0)GO TO 90
51800		M=ROFF(-H*RHT+RXGP)
51900		N=ROFF(G*DIS+XGP)
52000		GO TO 80
52100	90	M=ROFF(G*DIS)
52200		N=ROFF(H*RHT)
52300	80	CALL PLOT(M,N,3)
52400	300	NN=ID-1
52500	C  LAST OF ARRAY-1
52600		P=IA*RXX
52700		CALL UNPACK(IG,H,IFILL(I+1))
52800		RB=IG*RXX+PX
52900		J=1
53000	1	JJ=1
53100		IF(PX)GO TO 30
53200		IF(RM.GT.RB)GO TO 13
53300		GO TO 31
53400	30	IF(RM.LT.RB)GO TO 13
53500	31	IF(J)GO TO 2
53600	3	CALL NNN(NN,1,0,IFILL)
53700	C  FINDS BOTTOM POINTER
53800		GO TO 16	
53900	2	CALL NNN(I,0,1,IFILL)
54000	C  FINDS TOP POINTER(I)
54100	16	CALL UNPACK(JAX,JB,IFILL(N))
54200		CALL UNPACK(JG,JH,IFILL(N+1))
54300		CALL UNPACK(IQ,H,IFILL(NQ))
54400		RZ=RZ*RXX
54500	10	RDIS=JAX-JG
54600		IF(PX)GO TO 32
54700		IF(P.GT.RZ)P=RZ
54800		GO TO 33
54900	32	IF(P.LT.RZ)P=RZ
55000	C  REVERSES VERT.
55100	33	Q=IQ*RXX
55200		C=IC*RXY+RYX
55300		IF(RDIS.NE.0)GO TO 6
55400	C  FOR STRAIIGHT UP-DOWN LINES
55500		IF(NN-1.EQ.I)GO TO 13
55600		P=P-PX
55700		GO TO 5
55800	6	H=BZ*(JB-JH)/RDIS
55900	11	HH=(P-Q)*H+C
56000		PP=P+RBZ
56100		IH=ROFF(HH)
56200		IP=ROFF(PP)
56300	C  ROFF IS FOR ROUND-OFF ERRORS
56400		IF(IP.EQ.MP.AND.IH.EQ.MH)GO TO 180
56500		MP=IP
56600		MH=IH
56700	C  OMITS REPEATED POINTS
56800		IF(IPLT)GO TO 17
56900	CC	IF(RSZ.LE.0.8571)GO TO 34
57000	CC	IP=IP-JCEN
57100	CC	IH=IH-KCEN
57200	CC34	CALL AVECT(IP,IH)
57300		CALL LINES(PP/RSZ,HH/RSZ,2)
57400		GO TO 180
57500	17	IF(IXRX.EQ.0)GO TO 19
57600		K=IP
57700		IP=-IH+JXGP
57800	C NO RNDOFF OR DIS-RHT FACTORS HERE YET.
57900		IH=K+IXGP
58000	19	CALL PLOT(IP,IH,2)
58100	180	JJ=JJ-1
58200		IF(JJ)GO TO 12
58300		RM=P
58400		P=P+PX
58500		IF(PX)GO TO 35
58600		IF(P.LT.RZ)GO TO 11
58700		GO TO 5
58800	35	IF(P.GT.RZ)GO TO 11
58900	5	IF(J)GO TO 4
59000		NN=NN-1
59100		IF(I.GT.NN)GO TO 13
59200		GO TO 3
59300	4	I=I+1
59400		IF(I.GT.NN)GO TO 13
59500	402	CALL UNPACK(IA,IB,IFILL(I+1))
59600		RB=IA*RXX+PX
59700		GO TO 2
59800	12	J=-J
59900		GO TO 1
60000	13	NX=ID+1
60100		IF(ID.EQ.IFILL(1))GO TO 130
60200		ID=IFILL(NX)
60300		GO TO 100
60400	130	MP=1000
60500		MH=1000
60600		RETURN
60700		END
60800	
60900		SUBROUTINE NNN(J,L,K,IFILL)
61000		COMMON /FL/IC,N,NQ,RZ,XGP
61100		DIMENSION IFILL(1)
61200		CALL UNPACK(IZ,IC,IFILL(J+K))
61300		CALL UNPACK(N,IC,IFILL(J+L))
61400		N=J
61500	C  C IS THE CONSTANT
61600		NQ=N+L
61700		RZ=IZ
61800		RETURN
61900		END
62000	
62100		SUBROUTINE UNPACK(M,N,I)
62200		COMMON/LL/L
62300	C  L IS FOR VIS. OR INVIS. LINES.
62400		N=I
62500		L=2
62600		IF(N.LT.100000000)GO TO 2
62700		L=3
62800		N=N-100000000
62900	2	M=N/10000
63000		N=N-M*10000
63100		IF(M.GT.1000)M=1000-M
63200		IF(N.GT.1000)N=1000-N
63300		RETURN
63400		END
63500	
63600		FUNCTION ROFF(R)
63700		S=.5
63800		IF(R)S=-S
63900		ROFF=R+S
64000		RETURN
64100		END
65000	C******   CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
65100		SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
65200		COMMON/DL/IXRX,SAVER,NAME
65300		COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
65400		DIMENSION IDAT(1)
65500		COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
65600		DATA MP/2/,MD/6/
65700	C MD=DISPLAY   MP=PLOTTER   MX=XGP
65800		DX=DIS
65900		RX=RHT
66000		D=RSTJC*RJF
66100		R=RSTJC*RJG
66200	4	GO TO 1
66300		C=CC
66400		B=BB
66500	C  SAVES IT.  IT WILL RETURN LATER.
66600		BB=B/DIS
66700		CC=1000
66800	1	KK=0
66900		DO 205 J=1,L
67000		CALL UNPACK(M,N,IDAT(J))
67100		KK=KK+1
67200		NX(KK)=0
67300		IF(LL.EQ.3)NX(KK)=3
67400		X(KK)=ROFF((RJB+D*M)*DIS)
67500		Y(KK)=ROFF((CENTR+R*N)*RHT)
67600	3	GO TO 205
67700		Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
67800	C  FOR DISTORTION
67900	205	CONTINUE
68000		NX(1)=KK
68100		DIS=1.0
68200		RHT=DIS
68300		M=MD
68400		IF(IPLT)M=MP-IXRX
68500	C  STOPS DISTORTION IN 'LINES'
68600	2	CALL FILLER(X,Y,NX,M)
68700		DIS=DX
68800		RHT=RX
68900	5	RETURN
69000	C  NEXT TO RESET DISTORTION FACT.
69100		BB=B
69200		CC=C
69300		RETURN
69400		END
69500	
69600		SUBROUTINE ROTATE(I,L)
69700		DIMENSION I(1)
69800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RR(8),RSTJC
69900		EQUIVALENCE (RJF,RJQ(4)),(RJG,RJQ(5)),(DEG,RJQ(7))
70000		RJG=RJG*RSTJC
70100		RJF=RJF*RSTJC
70200		N=I(L)
70300		KNT=501
70400	C  ROTATED DATA IS PUT BACK STARTING AT LOCATION 501.
70500		I(KNT)=N
70600		DO 1 K=L+1,N+L-1
70700		CALL UNPACK(J,M,I(K))
70800		X=J*RJF
70900		Y=M*RJG
71000		JJ=I(K)/100000000
71100		AX=ATAN2(X,Y)*57.29578
71200		HYP=SQRT(X**2+Y**2)
71300		ROT=DEG+AX
71400		J=ROFF(HYP*COSD(ROT))
71500		M=ROFF(HYP*SIND(ROT))
71600		KNT=KNT+1
71700		IF(J)J=1000-J
71800		IF(M)M=1000-M
71900	1	I(KNT)=M*10000+J+JJ*100000000
72000		L=501
72100		RJF=1.
72200		RJG=1.
72300		RSTJC=1.
72400	C  SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
72500		END